C  SUBRS. VLINE, ASKIT, GRED, LPEN, SAVIT, LISTP ***************


	SUBROUTINE VLINE(R3,R4,R5,R6)
	INTEGER ASK
	COMMON /MKX/KSLA,ISEMI,LESS,IGT/A2Z/LAA,LBB,NONO(9),LEL
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /IDEV/IDEV
267 	CALL TYPSTR('TYPE STAFF #, POS1, POS2 AND CODE #  ')
	READ(IDEV,F78F,END=167)R3,R4,R5,R6
CQQ	ACCEPT F78F,R3,R4,R5,R6
	REREAD FA1,ASK
	IF(ASK.EQ.LESS)GO TO 167
	IF(ASK.NE.IGT)GO TO 2
	IDEV=1
	GO TO 267
2	IF(ASK.EQ.LBB)R3=99
C  99 IS ALSO USED IN MOVER.F4
	IF(R3.GE.99)RETURN
	IF(ASK.NE.LEL)GO TO 66
C  TYPE 'L' FOR LIGHT-PEN
	K=-1
67	R4=RY
	CALL LPEN(R3,RY,RX)
	REREAD FA1,ASK
	IF(ASK.EQ.LBB)R3=99
	IF(R3.GE.99)RETURN
	K=-K
	IF(K.GT.0)GO TO 67
	R5=RY
C LIGHT PEN IS READ TWICE
66	ASK=-1
	IF(R6.LT.100)GO TO 1
	R6=R6-100
C  FOR 'ASK' ADD 100 TO PARAM NUMBER GIVEN.
	ASK=0
1	CALL BOX(-1,R4)
	CALL BOX(-2,R5)
C  PUTS UP TWO VERTICAL LINES
	RETURN
CCC3	FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #  '$)
167	IDEV=5    
	GO TO 267
	END


	SUBROUTINE ASKIT
	INTEGER ASK
	COMMON /DPY/ST(4000),MEDIT,IGO/A2Z/NONO(6),LGG
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
	COMMON /XRN/RN(1) /KJY/ K,JY
	IGO=0
	CALL DPYNEW
	X=ST(2)
	CALL BOX(JY,RN(JY+2))
	ST(2)=X
  	CALL TYPSTR('N=NO, <CR>=YES, G=GO  ')
	ACCEPT FA1,K
	IF(K.EQ.LGG)ASK=-1
	CALL DPYNEW
	IGO=1
	END

	SUBROUTINE GRED
	INTEGER PWDS
	COMMON /MKX/KSLA,ISEMI,LESS,IGT
	1/A2Z/LAA,LBB,NONO(9),LEL,LMM,LNN,NON(9),LXX
	COMMON /DPY/IST(4000),MEDIT,IGO /IDEV/IDEV
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /KJY/ K,JY
	COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
	COMMON R2,JA,J,J2,RJQ(6),RC,IZ,RX,KV,RY,IA,IB,C,D,JZ,A,
	1 NX,VY,RB,JQ(20) /XRN/RN(1) /ALF/INP(72),ML
	COMMON /PTR/PWDS(1) /POSI/STFF(8),JJB,POS
	1 /LIMIT/LIMIT,ITEM,L,I,IX
	1 /RINP/R(10,80),RPOS(100) /DPTR/IWDS(1)

	EQUIVALENCE (IST2,IST(2))
	RC=999
	RSTF=RC
CC **CAN'T GET HERE ***IF(INP(1).NE.'A'.AND.INP(1).NE.'D')GO TO 1
C  LEAVES ROUTINE
7	CALL VLINE(R2,Z,POS,RX)
C  PUTS UP TWO VERTICAL LINES
	REREAD FA1,NX
	IF(NX.EQ.LBB)GO TO 170
	IF(R2.LT.99)GO TO 70
170	JA=98
	RETURN
70	IF(POS.EQ.0)POS=200
C  0,0  DOES WHOLE STAFF
	IF(INP(1).NE.LAA)GO TO 4
267	CALL TYPSTR(' TYPE P#, CHNG,  P#, CHNG,  P#, CHNG, ...')
	CALL TYPCRLF
	READ(IDEV,F78F,END=167)V
CQQ	ACCEPT F78F,V
	REREAD FA1,K
C  TYPE 'L' FOR LIGHT PEN
	IF(K.EQ.LESS)GO TO 167
	IF(K.NE.IGT)GO TO 367
	IDEV=1
	GO TO 267
367	IF(V(1).EQ.99)GO TO 7
	IF(K.EQ.LBB)GO TO 7
C TYPE 'B' OR 99 TO BACKUP
	IF(K.NE.LEL)GO TO 66
	DO 67 K=1,2
	V(2)=RY
	CALL LPEN(V(1),RY,RX)
	REREAD FA1,JA
	IF(JA.EQ.LBB)GO TO 7
67	IF(V(1).GE.99)GO TO 7
	V(3)=RY
66	JA=0
	IZ=0
C  COUNTER
	GO TO 14
167	IDEV=5
	GO TO 267
4	JA=98
C  FOR DELETIONS
C  STF.N, -99    -- DELETES ALL BUT STAFF N.
	IF(Z.NE.-99)GO TO 14
	RSTF=R2
	R2=99
14	NX=0
C  LOOP STARTS HERE
	J=0
140	NX=NX+1
142	JY=PWDS(NX)
	RB=RN(JY+3)
	IF(RTLINE(JY))GO TO 6
	IF(RB.LT.Z)GO TO 6
	IF(RB.GT.POS)GO TO 6
	IF(RN(JY+2).EQ.RSTF)GO TO 6
C  FOR -99 DELETES.
	RB=RN(JY+1)
	IF(V(1).EQ.12)GO TO 77
	IF(V(1).EQ.100)GO TO 341
C USE P100 AND ANY CODE# TO CREATE CUES. I.E. MINI NOTES, RESTS, BEAMS.
	IF(RC.EQ.999)GO TO 143
C  USE P12 TO INVERT STEM, BEAM AND SLURS ALL AT ONCE.
C  SET 12 TO 1 WITH CODE 5 TO INVERT SLURS ONLY
77	RC=0
	IF(RB.EQ.5)GO TO 141
	IF(RB.NE.6)GO TO 143
	IF(RX.EQ.1)GO TO 141
143	IF(RB.NE.RX.AND.RX.NE.0)GO TO 6
	IF(ASK)GO TO 100
	CALL ASKIT
	IF(K.EQ.LNN)GO TO 6
	IF(K.EQ.LXX)GO TO 19
100	IF(INP(1).EQ.LAA)GO TO 141
	IF(J)GO TO 40
	J=-1
	K=NX
41	IZ=NX
	IF(NX.LT.ITEM)GO TO 140
40	IF(NX-IZ.EQ.1)GO TO 41
C  GO BACK FOR MORE - IF IN RIGHT ORDER.
C  RANGE TO DEL. = K→NX
45	J=IZ+1
	IA=PWDS(K)
	IB=PWDS(J)-IA
	JZ=IWDS(K)
	J2=IWDS(J)-JZ
	J=J-K
	ITEM=ITEM-J
	DO 42 IZ=K,ITEM+1
	PWDS(IZ)=PWDS(IZ+J)-IB
42	IWDS(IZ)=IWDS(IZ+J)-J2
	IST2=IST2-J2
	I=I-IB
	 CALL LOOP(IA,I,1,0,IB,RN)
	CALL LOOP(JZ+2,IST2+2,1,0,J2,IST)
	IF(K.GE.ITEM)GO TO 1
C  EXITS
	NX=K+1
	GO TO 142
341	IF(RB.EQ.6)GO TO 141
	IF(RB.GT.2)GO TO 6
141	IF(IZ.GE.97)GO TO 9
C   THERE'S A LIMIT TO THE R ARRAY    4/18/73
	IZ=IZ+1
C  FOUND AN ITEM
	R(1,IZ)=22
	R(2,IZ)=NX
10	IZ=IZ+1
	DO 101 KV=3,10
101	R(KV,IZ)=0
	IF(V(1).NE.100)GO TO 131
231	R(1,IZ)=400
C  MAKES MINI NOTES, RESTS, BEAMS
	R(2,IZ)=100
	GO TO 6
131	IF(RC.EQ.999)GO TO 11
	IF(RB.EQ.1)GO TO 30
31	RC=RN(JY+7)
	IF(RB.EQ.6)GO TO 32
C  NEXT INVERTS DIP
	IF(RX.EQ.1)GO TO 35
	A=-1.6
	RB=-10
	IF(RC)A=-A
CC***????  WHY CHANGE P2???  ****36	R(7,IZ)=2
CC***	R(8,IZ)=RN(JY+2)+A
	GO TO 37
35	RB=-4
	IF(RN(JY+8).LT.-1)RB=-1.4
C  2 AND .7 ARE HGTS SET IN 'BEAMS'
37	IF(RC)RB=-RB
	R(3,IZ)=4
	R(4,IZ)=RN(JY+4)+RB
	R(6,IZ)=RN(JY+5)+RB
	R(5,IZ)=5
33	R(1,IZ)=7
	R(2,IZ)=-RC
	GO TO 6
32	IF(RC.LT.20)GO TO 34
C  THIS IS FOR BEAMS
232	RC=10-RC
	GO TO 33
132	IF(RC.GT.-20)GO TO 232
	GO TO 332
34	IF(RC)GO TO 132
C  P7 IS NEG FOR TREMOLOS
332	RC=-10-RC
	GO TO 33

C  NEXT INVERTS STEMS EITHER WAY. USE ANY #>11 WITH CODE 1 TO INVERT.
C  MUST! BE FIRST IN LIST!!!
C	RC=0
30	RB=RN(JY+5)
	IF(RB.LT.10)GO TO 12
C  NO STEM < 10
	RC=10
	IF(RB.GE.20)RC=-RC
	RB=RB+RC
12	V(1)=5.
	V(2)=RB
C  SO IT WILL DISPLAY RESULT
11	DO 8 K=1,10
8	R(K,IZ)=V(K)
6	IF(J)GO TO 45
	IF(NX.LT.ITEM)GO TO 140
19	IF(INP(1).NE.LAA)GO TO 1
9	R(1,IZ+1)=222
	R(1,IZ+2)=0
CC	REND=-1.
1	CALL HYDPOG(3)
	END

	SUBROUTINE LPEN(A,B,C)
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /SIZ/RSZ,JCEN,KCEN
	COMMON /POSI/STFF(0/7),JJ2,POS /ALF/INP(71),M,L /C/MM,LL
	COMMON /A2Z/LAA,LBB,NONO(21),LXX
CC5	CALL SETCUR(0,100,0)
	M=MM
	L=LL
	IF(IABS(M).GT.512)GO TO 4
	IF(IABS(L).LE.512)GO TO 3
4	M=0
	L=100
3	CALL SETCUR(M,L,0)
	CALL TYPSTR('TYPE <CR> TO SET POINT')
	ACCEPT FA1,JD
	IF(JD.EQ.'9')RETURN
	IF(JD.EQ.LXX)RETURN
C  TYPE 'B' OR 99 TO BACK UP
	IF(JD.EQ.LBB)RETURN
	CALL RDCUR(M,L)
CC	CALL CLRCUR
	L=(L+KCEN)/RSZ
1	B=((M+JCEN)/RSZ+596.0)/5.96
C  B=HORIZ. STEP NUM.
	DO 13 K=0,7
	M=STFF(K)+60.
	IF(L.GT.M)GO TO 13
	A=K
C  A=STAFF NUM.
	GO TO 8
13	CONTINUE
8	C=IFIX((L-STFF(K)+21.)/7.+.5)
C  FINDS VERT. NOTE NUM.
	TYPE F78F,A,B
	END


	SUBROUTINE SAVIT
	IMPLICIT INTEGER(A-Q,S-Z)
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/DL/X22,SAVER,NAME,EXT
	1 /POSI/STFF(0/7),JJ2,IPOS /LIMIT/LIMIT,ITEM,L,I,IX 
	1 /SCM/V(78),ISCR,LCNT,IRSTF,LIST(200),REND 
	1 /ALF/INP(72),ML/XRN/RN(1)/DPY/ST(4000),MEDIT,IGO
	1 /STF/RSTFAC(0/7),RSTJ2 /PTR/PWDS(1) /JCHAR/IXX,ISEMI,IBLA
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	COMMON /A2Z/LAA,LBB,LCC,LDD,NONO(8),LMM,LNN,NON(4),LSS
CC	DATA EXT/'DMD'/
	DIMENSION SV(128)
	EQUIVALENCE (INP2,INP(2)),(ST2,ST(2)),(SV,LIST)
C  'SAME' WILL REPEAT CURRENT NAME.  BLANK WILL USE TMP.DMD
	KX=-1
	K=0
32	K=K+1
C  THIS IS TO REPAIR DAMAGE DONE BY UNKNOWN BUGS!!!!
33	L=PWDS(K)
	IA=PWDS(K+1)
	IB=RN(L)+3.+L
C  THIS SHOULD BE NEW POINTER
	IF(IA-IB.EQ.0)GO TO 36
	IF(RN(IB)+3+IB.NE.PWDS(K+2))GO TO 38
	J=K+1
	PWDS(J)=IB
	CALL TYPSTR('?FIXED UP ITEM ')
	CALL TYPINT(J)
	CALL TYPCRLF
	GO TO 36
38	IJ=IA-L
	DO 39 J2=K+1,ITEM
39	PWDS(J2)=PWDS(J2+1)-IJ
	CALL TYPSTR('BAD ITEM--')
	CALL TYPINT(K)
	CALL TYPCRLF
	IF(KX.EQ.0)GO TO 50
	CALL TYPSTR('NAME.EXT? ')
CF	ACCEPT FA5,NAME
	ACCEPT 141,INP
	CALL NAMEXT(INP,NAME,EXT)
C  ONLY DOES THIS ON THE FIRST ERROR
	GO TO 2
50	J=RJ
	KX=0
	CALL LOOP(L,I,1,0,J,RN)
C  REARRANGES DATA
	I=I-J
	ITEM=ITEM-1
	IF(ITEM.LE.K)GO TO 37
	GO TO 33
C  GO BACK AND TRY AGAIN
36	IF(IA.LE.L)GO TO 38
C  JUMP IF PWDS IS OUT OF ORDER
	IF(K.LT.ITEM)GO TO 32
37	KX=-1
	IF(SAVER.GE.0)GO TO 10
CC101	REWIND 21
	SAVER=4
101	CALL PUTEXT('TMP','DMD')
	GO TO 102
1	FORMAT(I,24F)
2	CALL TYPCHR('WRITE OVER   ',13)
	CALL TYPWRD(NAME)
	CALL TYPCHR('.',1)
	CALL TYPCHR(EXT,3)
	CALL TYPCHR('?  ',3)
CF	ACCEPT FA1,L
CF	IF(L.NE.'N')GO TO 4
	ACCEPT 141,INP
	IF(INP(1).NE.LNN)GO TO 4
CXX10	IF(INP2.NE.'M')GO TO 11
CXX	INP2='B'
CXX	GO TO 4
10	IF(INP2.EQ.LMM)GO TO 4
11	L=NAME
	INP(1)=-1
	CALL NAMEXT(INP,NAME,EXT)
CF	CALL FORMAT(NAME)
	IF(NAME.NE.IBLA)GO TO 40
	CALL TYPSTR('NAME.EXT? ')
CF	ACCEPT 141,NAME,X,X
	ACCEPT 141,INP   
	CALL NAMEXT(INP,NAME,EXT)
	IF(NAME.EQ.IBLA)GO TO 4
CF	IF(X.NE.IBLA)EXT=X
C 99 WILL BACK UP.
	IF(NAME.NE.'99')GO TO 40
	NAME=L
	RETURN
40	IF(NAME.NE.'SAME')GO TO 43
	NAME=L
	GO TO 4
141	FORMAT(72A1)
CF141	FORMAT(A5,A1,A3)
CC43	IF(LOOKD(NAME))GO TO 2
43	IF(LOOKX(NAME,EXT))GO TO 2
C  JUMP BACK IF FILE NAME ALREADY ON DSK
4	IF(KX.EQ.0)GO TO 50
CC	REWIND 21
	IF(NAME.NE.IBLA)GO TO 41
	NAME=L
	GO TO 101
CC	CALL OFILE(21,NAME)
41	CALL PUTEXT(NAME,EXT)
CC	GO TO 42
CC41	NAME=L
42	IF(INP2.EQ.LDD)GO TO 202
C   SB=SAVE BIG;  SD=SAVE DPY ONLY; SM=SB WITH SAME NAME
102	IRSTF=0
	IF(INP2.EQ.LBB)IRSTF=-1
	JJ2=ITEM+2
	IPOS=I
C WD CNTS
	CALL EXTOUT(RSTFAC,128)
C  INCLUDES STFF AND V ARRAYS
	CALL EXTOUT(PWDS,JJ2)
	CALL EXTOUT(RN,IPOS)
	IF(LCNT.GT.1)CALL EXTOUT(LIST,LCNT)
CC102	WRITE(21)ITEM,I
CC	1,(PWDS(L),L=1,ITEM+1),(RN(L),L=1,I-1),ISCR,(V(L),L=1,ISCR),
CC	1 LCNT,(LIST(L),L=1,LCNT),RSTFAC,STFF,SV
C (SV) FOR FORTRAN READ BUG!!!!
CC	IF(SAVER.GE.0)WRITE(21)RSTFAC,STFF,L
C NOT USED WHEN SAVE IS AUTOMATIC.
C  TAKE OUT ABOVE WHEN BUG IS SOMEDAY FIXED IN F4.
	IF(I.LE.LIMIT)GO TO 20
	CALL TYPSTR('****** TOO MUCH DATA TO PRINT - ')
	CALL TYPINT(I)
	CALL TYPCHR('/',1)
	CALL TYPINT(LIMIT)
CC	IF(INP2.NE.'B')GO TO 1001
20	IF(INP2.EQ.LBB)CALL EXTOUT(ST,4302)
CC	WRITE(21)ST2,(ST(L),L=1,ST2+2),(WDS(L),L=1,ITEM+1)
CC1001	END FILE 21
1001	CALL FINEXT
	IF(INP(1).NE.LSS)RETURN
CCCC	IF(NAME.EQ.' ')TYPE 5600
	IF(NAME.NE.IBLA)RETURN
	CALL TYPSTR('DISPLAY SAVED IN "TMP.DMD"')
	CALL TYPCRLF
C   GO BACK IF THE SAVER WROTE THE FILE
	RETURN
202	WRITE(21),ST2,(ST(L),L=1,ST2+2)
 	GO TO 1001
C   WRITES DPY BUFFER ONLY.
	END

	SUBROUTINE LISTP(LST)
	IMPLICIT INTEGER(A-Q,S-Z)
	DIMENSION LST(1)
	COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),K,JY,X,Y /XRN/RN(1)
	1 /STF/RSTFAC(0/7),RSTJ2 /LIMIT/LIMIT,ITEM,L,I,IX /PTR/PWDS(1)
	EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(RJC,RJQ(1)),(RJD,RJQ(2))

	CALL NOZERO(R2)
	JC=RJC
	IF(JC.EQ.0)JC=ITEM
	JY=5
	JD=RJD
	IF(JD.NE.0)JY=3
	DO 6334 L=IFIX(R2),JC
	X=PWDS(L)
	Y=RN(X)+2+X
	X=X+1
	K=RN(X)
CC	IF(K.EQ.13)K=11
CC	IF(K.GE.11)K=K-1
CC	IF(K.GE.15)K=K-4
6334	WRITE(JY,6333),L,LST(K),(RN(K),K=X,Y)
C  P, N1, N2, N3  TYPES ITEM LIST. N1=1ST, N2=LAST, N3=TO LPT?
C  LEAVE THIS HERE SO WRITE(JY, OF R IS POSSIBLE IN DDT
CCC63331	FORMAT(8F10.4)
6333	FORMAT(I4,') ',A5,2F4.0,F8.3,F8.2,7F10.2)
	END